VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsHon"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Declare Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" (ByRef Destination As Any, ByVal Length As Long)

'size=32*32

'PING size=384*256

Private Type typeObj
 x As Single
 y As Single
 vx As Single
 vy As Single
 '///
 nFlags As Long
 '1=collision with top
 '///
 nReserved2 As Long
 '///
 m As Single 'mass
 '///
 nType As Integer
 '0=nond
 '1-15=normal colored block
 'TODO: etc.
 nTime As Integer
 '-1=deleted
 '0=normal
 '1-xx ?? = about to delete
End Type

Private Type typeEdge
 idx1 As Integer
 idx2 As Integer
 fLength As Single
End Type

#Const FixedSizeArray = True

#If FixedSizeArray Then

Private Const objm As Long = 4096
Private objs(1 To objm) As typeObj
Private objHitTest(1 To objm) As Long

#Else

Private objs() As typeObj, objm As Long
Private objHitTest() As Long
'0  = hit = 0
'>0 = hit = 1 (index)
'-1 = hit >=2

#End If

Private objc As Long

Private Const nDeleteTime As Long = 160

#If FixedSizeArray Then

Private Const em As Long = 4096
Private es(1 To em) As typeEdge

#Else

Private es() As typeEdge, em As Long

#End If

Private ec As Long

'//////////////////////some constants
Private Const TheRadius As Single = 16
Private Const TheDiameter As Single = TheRadius * 2
Private Const TheWidth As Single = 256
Private Const TheHeight As Single = 384
Private Const kObj As Single = 5
Private Const kBorder As Single = 5
Private Const kString As Single = 1
Private Const miuBorder As Single = 0.1 'fraction
Private Const TheDecay As Single = 0.9 'hit test position decay (xNew/x)
Private Const TheGravity As Single = 1
'//////////////////////
Private Const Const1 As Single = TheWidth - TheRadius
Private Const Const1_1 As Single = TheHeight - TheRadius
Private Const Const2 As Single = TheDiameter * TheDiameter
'//////////////////////
#Const UseLinkedList = True

'linked-list array
#If FixedSizeArray Then
Private objNext(1 To objm) As Long
#Else
Private objNext() As Long
#End If
'grid size= 2*sqr(2)*R=2.828R (for square blocks,2R for round blocks)
Private objGrid(5, 11) As Long

'////////////////

Private nColorMax As Long '1 to nColorMax is normal color
Private nRockMax As Long 'nColorMax+1 to nRockMax is rock

Private nExplosiveRock As Long

'////////////////

Private m_objCallback As clsHon

Friend Property Get ExplosiveRock() As Long
ExplosiveRock = nExplosiveRock
End Property

Friend Property Let ExplosiveRock(ByVal n As Long)
nExplosiveRock = n
End Property

Friend Sub AddExplosion(ByVal x As Single, ByVal y As Single, ByVal r As Single, ByVal f As Single)
Dim x1 As Single, y1 As Single, f1 As Single
Dim d As Single
Dim i As Long
'///
For i = 1 To objc
 With objs(i)
  If .nTime <> -1 Then
   x1 = .x - x
   y1 = .y - y
   d = Sqr(x1 * x1 + y1 * y1)
   f1 = 1 - d / r
   If f1 > 0 And d > 0.000001! Then
    f1 = f1 * f / d / .m
    .vx = .vx + x1 * f1
    .vy = .vy + y1 * f1
   End If
  End If
 End With
Next i
'///
If Not m_objCallback Is Nothing Then
 m_objCallback.OnExplosion x, y, r
End If
End Sub

Public Sub OnExplosion(ByVal x As Single, ByVal y As Single, ByVal r As Single)
'
End Sub

Friend Property Get CallbackObject() As clsHon
Set CallbackObject = m_objCallback
End Property

Friend Property Set CallbackObject(ByVal obj As clsHon)
Set m_objCallback = obj
End Property

Friend Property Get ColorMax() As Long
ColorMax = nColorMax
End Property

Friend Property Let ColorMax(ByVal n As Long)
nColorMax = n
End Property

Friend Property Get RockMax() As Long
RockMax = nRockMax
End Property

Friend Property Let RockMax(ByVal n As Long)
nRockMax = n
End Property

Friend Sub Calc_RoundShaped(ByVal DeltaT As Single, Optional ByVal nIterations As Long = 1, Optional ByVal bCalc2 As Boolean = True, Optional nDeleted As Long)
On Error Resume Next
Dim i As Long, j As Long, k As Long
Dim ii As Long, jj As Long
Dim x As Long, y As Long
Dim xMin As Long, yMin As Long
Dim xMax As Long, yMax As Long
Dim f As Single, f1 As Single, f2 As Single
Dim fX As Single, fY As Single
'///
Dim nType As Long, nType2 As Long
'///
'chear hit test data
If bCalc2 And objc > 0 Then
 ZeroMemory objHitTest(1), objc * 4&
 For i = 1 To objc
  With objs(i)
   If .nTime > 0 And .nTime < nDeleteTime Then
    objHitTest(i) = -1 - .nTime
   End If
  End With
 Next i
End If
'TODO:don't calc the constants too many times
Do While nIterations > 0
 nIterations = nIterations - 1
 #If UseLinkedList Then
 'init linked list (slow??)
 Erase objGrid
 For i = 1 To objc
  With objs(i)
   If .nTime <> -1 Then
    j = CLng(.x) \ 46&
    k = CLng(.y) \ 46&
    If j < 0 Then j = 0 Else If j > 5 Then j = 5
    If k < 0 Then k = 0 Else If k > 11 Then k = 11
    'insert node
    objNext(i) = objGrid(j, k)
    objGrid(j, k) = i
   End If
  End With
 Next i
 #End If
 'gravity and hit test
 For i = 1 To objc
  With objs(i)
   If .nTime <> -1 Then
    '///
    f1 = 1 / .m
    '///gravity
    .vy = .vy - TheGravity * DeltaT
    'bottom hit test
    f = .y - TheRadius
    If f < 0 Then
     .y = TheRadius + f * TheDecay
     .vx = .vx * (1 - miuBorder * DeltaT)
     .vy = .vy - f * kBorder * DeltaT * f1
    End If
    'top hit test
    f = .y - Const1_1
    j = .nFlags
    If j And &H1& Then
     If f > 0 Then
      .y = Const1_1 + f * TheDecay
      .vx = .vx * (1 - miuBorder * DeltaT)
      .vy = .vy - f * kBorder * DeltaT * f1
     End If
    ElseIf f < 0 Then
     .nFlags = j Or &H1& '??
    End If
    'left hit test
    f = .x - TheRadius
    If f < 0 Then
     .x = TheRadius + f * TheDecay
     .vx = .vx - f * kBorder * DeltaT * f1
     .vy = .vy * (1 - miuBorder * DeltaT)
    End If
    'right hit test
    f = .x - Const1
    If f > 0 Then
     .x = Const1 + f * TheDecay
     .vx = .vx - f * kBorder * DeltaT * f1
     .vy = .vy * (1 - miuBorder * DeltaT)
    End If
    'object hit test
    #If UseLinkedList Then
    '2D array+linked list
    x = CLng(.x) \ 46&
    y = CLng(.y) \ 46&
    If x < 0 Then x = 0 Else If x > 5 Then x = 5
    If y < 0 Then y = 0 Else If y > 11 Then y = 11
    If x < 1 Then xMin = 0 Else xMin = x - 1
    If x > 4 Then xMax = 5 Else xMax = x + 1
    If y < 1 Then yMin = 0 Else yMin = y - 1
    If y > 10 Then yMax = 10 Else yMax = y + 1
    For x = xMin To xMax
    For y = yMin To yMax
    j = objGrid(x, y)
    Do While j > 0
     If j > i Then
    #Else
    For j = i + 1 To objc
     If objs(j).nTime <> -1 Then
    #End If
      fX = objs(j).x - .x
      fY = objs(j).y - .y
      f = fX * fX + fY * fY
      Debug.Assert f > 0
      If f < Const2 Then
       f = Sqr(f)
       f = kObj * (TheDiameter - f) * DeltaT / f
       fX = fX * f
       fY = fY * f
       'decay??
       .x = .x - fX * (1 - TheDecay)  '??
       .y = .y - fY * (1 - TheDecay)  '??
       .vx = .vx - fX * f1
       .vy = .vy - fY * f1
       With objs(j)
        f2 = .m
        .x = .x + fX * (1 - TheDecay)  '??
        .y = .y + fY * (1 - TheDecay)  '??
        .vx = .vx + fX / f2
        .vy = .vy + fY / f2
       End With
       '//////////////////////////game calc
       If bCalc2 Then
        nType = .nType
        nType2 = objs(j).nType
        If nType > 0 And nType2 > 0 Then
         Select Case nType
         Case Is <= nColorMax
          Select Case nType2
          Case nType 'same color!!
           jj = objHitTest(i)
           ii = objHitTest(j)
           If i = ii And j = jj Then
            'do nothing
           ElseIf ii = 0 And jj = 0 Then
            objHitTest(i) = j
            objHitTest(j) = i
           Else 'deleted!!
            'get min
            k = -1
            If k > ii Then k = ii
            If k > jj Then k = jj
            If ii > 0 And ii <> i Then
             If k > objHitTest(ii) Then k = objHitTest(ii)
            End If
            'set flags
            If jj > 0 And jj <> j Then
             If k > objHitTest(jj) Then k = objHitTest(jj) Else objHitTest(jj) = k
            End If
            If ii > 0 And ii <> i Then
             If objHitTest(ii) > k Then objHitTest(ii) = k
            End If
            objHitTest(i) = k
            objHitTest(j) = k
           End If
          Case nColorMax + 1 To nRockMax
           If objHitTest(i) < 0 Then objHitTest(j) = objHitTest(i)
          End Select
         Case nColorMax + 1 To nRockMax
          Select Case nType2
          Case Is <= nColorMax
           If objHitTest(j) < 0 Then objHitTest(i) = objHitTest(j)
          End Select
         End Select
        End If
       End If
       '//////////////////////////
      End If
     End If
    #If UseLinkedList Then
     j = objNext(j)
    Loop
    Next y, x
    #Else
    Next j
    #End If
   End If
  End With
 Next i
 'edge
 For i = 1 To ec
  With es(i)
   If .idx1 > 0 And .idx2 > 0 And .idx1 <> .idx2 Then
    If objs(.idx1).nTime <> -1 And objs(.idx2).nTime <> -1 Then
     fX = objs(.idx2).x - objs(.idx1).x
     fY = objs(.idx2).y - objs(.idx1).y
     f = fX * fX + fY * fY
     If f > Const2 Then
      f = Sqr(f)
      f = kString * (f - .fLength) * DeltaT / f
      fX = fX * f
      fY = fY * f
      With objs(.idx1)
       f1 = .m
       .vx = .vx + fX / f1
       .vy = .vy + fY / f1
      End With
      With objs(.idx2)
       f2 = .m
       .vx = .vx - fX / f2
       .vy = .vy - fY / f2
      End With
     End If
    End If
   End If
  End With
 Next i
 'calc new pos
 For i = 1 To objc
  With objs(i)
   If .nTime <> -1 Then
    .x = .x + .vx * DeltaT
    .y = .y + .vy * DeltaT
   End If
  End With
 Next i
Loop
'//////////////////////////game calc
If bCalc2 Then
 nDeleted = 0
 For i = 1 To objc
  With objs(i)
   k = objHitTest(i)
   If .nTime <> -1 And k < 0 Then
    .nTime = -k
    If .nTime >= nDeleteTime Then
     '///delete it
     RemoveObj i
     Select Case .nType
     Case nExplosiveRock
      AddExplosion .x, .y, 80 + .y / 16, 100 + .y / 16
     End Select
     '///
     nDeleted = nDeleted + 1
    End If
   End If
  End With
 Next i
End If
'//////////////////////////
End Sub

Friend Property Get ObjCount() As Long
ObjCount = objc
End Property

Friend Property Get EdgeCount() As Long
EdgeCount = ec
End Property

Friend Property Get IsObject(ByVal Index As Long) As Boolean
If Index > 0 And Index <= objc Then
 IsObject = objs(Index).nTime <> -1
End If
End Property

Friend Property Get IsEdge(ByVal Index As Long) As Boolean
If Index > 0 And Index <= ec Then
 IsEdge = es(Index).idx1 > 0
End If
End Property

Friend Sub GetObjData(ByVal Index As Long, Optional x As Single, Optional y As Single, Optional z As Single, Optional nType As Long, Optional nTime As Long)
With objs(Index)
 x = .x
 y = .y
 'z = .z
 nType = .nType
 nTime = .nTime
End With
End Sub

Friend Function AddObj(ByVal x As Single, ByVal y As Single, Optional ByVal z As Single, _
Optional ByVal vx As Single, Optional ByVal vy As Single, Optional ByVal vz As Single, _
Optional ByVal nType As Long, Optional ByVal nFlags As Long, Optional ByVal fMass As Single = 1) As Long
Dim i As Long
For i = 1 To objc
 If objs(i).nTime = -1 Then Exit For
Next i
If i > objc Then
 objc = objc + 1
 If objc > objm Then
  #If FixedSizeArray Then
  objc = objm
  Debug.Assert False
  Exit Function
  #Else
  objm = objm + 256
  ReDim Preserve objs(1 To objm)
  ReDim objHitTest(1 To objm)
  ReDim objNext(1 To objm)
  #End If
 End If
End If
With objs(i)
 .x = x
 .y = y
 '.z = z
 .vx = vx
 .vy = vy
 '.vz = vz
 .m = fMass
 .nType = nType
 .nTime = 0
 .nFlags = nFlags
End With
AddObj = i
End Function

Friend Function AddEdge(ByVal idx1 As Long, ByVal idx2 As Long, Optional ByVal fLength As Single = TheDiameter) As Long
Dim i As Long
For i = 1 To ec
 If es(i).idx1 <= 0 Then Exit For
Next i
If i > ec Then
 ec = ec + 1
 If ec > em Then
  #If FixedSizeArray Then
  ec = em
  Debug.Assert False
  Exit Function
  #Else
  em = em + 256
  ReDim Preserve es(1 To em)
  #End If
 End If
End If
With es(i)
 .idx1 = idx1
 .idx2 = idx2
 .fLength = fLength
End With
AddEdge = i
End Function

Friend Function RemoveEdge(ByVal Index As Long) As Boolean
If Index <= 0 Or Index > ec Then Exit Function
With es(Index)
 .idx1 = -1
 .idx2 = -1
End With
RemoveEdge = True
End Function

Friend Function RemoveObj(ByVal Index As Long) As Boolean
Dim i As Long
If Index <= 0 Or Index > objc Then Exit Function
With objs(Index)
 If .nTime <> -1 Then
  .nTime = -1
  For i = 1 To ec
   With es(i)
    If .idx1 = Index Or .idx2 = Index Then
     .idx1 = -1
     .idx2 = -1
    End If
   End With
  Next i
  RemoveObj = True
 End If
End With
End Function

Friend Sub Clear()
Erase objs, es, objHitTest, objNext
objc = 0
ec = 0
#If FixedSizeArray Then
#Else
objm = 0
em = 0
#End If
End Sub

Friend Sub ClearEdge()
Erase es
ec = 0
#If FixedSizeArray Then
#Else
em = 0
#End If
End Sub

Friend Property Get ObjX(ByVal Index As Long) As Single
ObjX = objs(Index).x
End Property

Friend Property Let ObjX(ByVal Index As Long, ByVal n As Single)
objs(Index).x = n
End Property

Friend Property Get ObjY(ByVal Index As Long) As Single
ObjY = objs(Index).y
End Property

Friend Property Let ObjY(ByVal Index As Long, ByVal n As Single)
objs(Index).y = n
End Property

Friend Property Get ObjZ(ByVal Index As Long) As Single
'ObjZ = objs(Index).z
End Property

Friend Property Let ObjZ(ByVal Index As Long, ByVal n As Single)
'objs(Index).z = n
End Property

Friend Property Get ObjVX(ByVal Index As Long) As Single
ObjVX = objs(Index).vx
End Property

Friend Property Let ObjVX(ByVal Index As Long, ByVal n As Single)
objs(Index).vx = n
End Property

Friend Property Get ObjVY(ByVal Index As Long) As Single
ObjVY = objs(Index).vy
End Property

Friend Property Let ObjVY(ByVal Index As Long, ByVal n As Single)
objs(Index).vy = n
End Property

Friend Property Get ObjVZ(ByVal Index As Long) As Single
'ObjVZ = objs(Index).vz
End Property

Friend Property Let ObjVZ(ByVal Index As Long, ByVal n As Single)
'objs(Index).vz = n
End Property

Friend Property Get ObjType(ByVal Index As Long) As Long
ObjType = objs(Index).nType
End Property

Friend Property Let ObjType(ByVal Index As Long, ByVal n As Long)
objs(Index).nType = n
End Property

Friend Property Get ObjFlags(ByVal Index As Long) As Long
ObjFlags = objs(Index).nFlags
End Property

Friend Property Let ObjFlags(ByVal Index As Long, ByVal n As Long)
objs(Index).nFlags = n
End Property

Friend Property Get EdgeIndex(ByVal Index As Long, ByVal idx As Long) As Long
Select Case idx
Case 1
 EdgeIndex = es(Index).idx1
Case 2
 EdgeIndex = es(Index).idx2
End Select
End Property

Friend Property Let EdgeIndex(ByVal Index As Long, ByVal idx As Long, ByVal n As Long)
Select Case idx
Case 1
 es(Index).idx1 = n
Case 2
 es(Index).idx2 = n
End Select
End Property
